(defpackage :session-file
  (:use :cl)
  (:nicknames :sf)
  (:export :read-all-sessions
           :equation-to-tree
           :equation-read-error
           :display
           :display-solutions
           :parse-graph))

(in-package :session-file)

(defun merge-it (thing)
  (apply 'concatenate 'string thing))

(defun rewrite-eqn (thing)
  (cons (first thing) (mapcar 'cdr (second thing))))

(defun postfix (list)
  "example: (x ((* y) (/ 8) (* 3) (/ 4)))) => (/ (* (/ (* x y) 8) 3) 4)"
  (labels ((doit (primary l)
             (cond
               ((null l) primary)
               (t
                (let ((tmp (doit primary (cdr l))))
                  (if (and (cdr l)
                           (eq (first (first l))
                               (first (second l))))
                      (append tmp (list (second (first l))))
                      (list (first (first l))
                            tmp
                            (second (first l)))))))))
    (doit (first list) (reverse (second list)))))

(defun intern-it (sym)
  (intern sym :session-file))

(defparameter *rules* `((digits (:many (:fn digit-char-p)))
                        (number (:rewrite (:or digits
                                               (:rewrite (#\- digits)
                                                         merge-it))
                                          parse-integer))
                        (symbol (:many (:fn alpha-char-p)))
                        (unknown #\?)
                        (op (:rewrite (:or #\+ #\- #\* #\/ #\=)
                                      find-symbol))
                        (equal (:rewrite #\= find-symbol))
                        (expr (:or (number op expr)
                                   (symbol op expr)
                                   (unknown op expr)
                                   ((:rewrite (#\( expr #\))
                                             second)
                                    op expr)
                                   (:rewrite (#\( expr #\))
                                             second)
                                   number
                                   symbol
                                   unknown))
                        (assign (#\, symbol (:rewrite #\= find-symbol) number))
                        (top (:or (:rewrite (expr (:many assign))
                                            rewrite-eqn)
                                  (expr)))))

(defun parse-ratio (things)
  (let ((neg (if (string= (first things) "-")
                 (progn (pop things) -1)
                 1)))
    (* neg (/ (parse-integer (first things))
              (parse-integer (third things))))))

(defparameter *rules2* `((digits (:many (:fn digit-char-p)))
                         (ratio (:rewrite (:or (digits #\\ digits)
                                               (#\- digits #\\ digits))
                                          parse-ratio))
                         (integer (:rewrite (:or digits
                                                (:rewrite (#\- digits)
                                                          merge-it))
                                           parse-integer))
                         (number (:or ratio integer))
                         (symbol (:many (:fn alpha-char-p)))
                         (unknown #\?)
                         (add-op (:rewrite (:or #\+ #\-) find-symbol))
                         (mul-op (:rewrite (:or #\* #\/) find-symbol))
                         (equal (:rewrite #\= find-symbol))
                         (bar (:rewrite #\| intern-it))
                         (expr equality-expr)
                         (bar-expr (:rewrite (equality-expr (:some (bar equality-expr)))
                                                  postfix))
                         (equality-expr (:rewrite (add-expr (:some (equal add-expr)))
                                                  postfix))
                         (add-expr (:rewrite (mul-expr (:some (add-op mul-expr)))
                                             postfix))
                         (mul-expr (:rewrite (primary (:some (mul-op primary)))
                                             postfix))
                         (primary (:or unknown symbol number parens))
                         (parens (:rewrite (#\( expr #\))
                                           second))
                         (assign (#\, symbol equal add-expr))
                         (top (:or (:rewrite (bar-expr (:many assign))
                                             rewrite-eqn)
                                   (bar-expr)))))

(define-condition rule-error (error)
  ())

(defgeneric parse (rule string rules))

(defmethod parse :around (rule string rules)
  (setf string (string-left-trim '(#\Space #\Tab) string))
  (call-next-method rule string rules))

(defun error-on-empty (string)
  (when (zerop (length string))
    (error 'rule-error)))

(defmethod parse ((rule character) string rules)
  (error-on-empty string)
  (if (char= rule (char string 0))
      (values (string rule) (subseq string 1))
      (error 'rule-error)))

(defmethod parse ((rule symbol) string rules)
  (error-on-empty string)
  (let ((r (find rule rules :key 'first)))
    (if r
        (multiple-value-bind (r rest) (parse (second r) string rules)
          (values r rest))
        (error 'rule-error))))

(defmethod parse ((rule list) string rules)
  (let ((op (first rule)))
    (case op
      (:or
       (dolist (r (rest rule) (error 'rule-error))
         (handler-case
             (return (parse r string rules))
           (rule-error ()))))
      (:many
       (multiple-value-bind (ret string) (parse (second rule) string rules)
         (loop
            with r = nil
            do (handler-case
                   (multiple-value-setq (r string) (parse (second rule) string rules))
                 (rule-error ()
                   (let ((ret (cons ret things)))
                   (return (values (if (every 'stringp ret)
                                       (apply 'concatenate 'string ret)
                                       ret)
                                   string)))))
            collect r into things)))
      (:some
       (loop
          with r = nil
          do (handler-case
                 (multiple-value-setq (r string) (parse (second rule) string rules))
               (rule-error ()
                 (return (values (if (every 'stringp things)
                                     (let ((s (apply 'concatenate 'string things)))
                                       (if (plusp (length s))
                                           s nil))
                                     things)
                                 string))))
          collect r into things))
      (:fn
       (error-on-empty string)
       (if (funcall (second rule) (char string 0))
           (values (string (char string 0)) (subseq string 1))
           (error 'rule-error)))
      (:rewrite
       (multiple-value-bind (r rest) (parse (second rule) string rules)
         (values (funcall (third rule) r)
                 rest)))
      (t
       (loop
          with r = nil
          for i in rule
          do (multiple-value-setq (r string) (parse i string rules))
          when r
          collect r into things
          finally (return (values things string)))))))

(define-condition equation-read-error (error)
  ((line :initarg :line :accessor line))
  (:report (lambda (c stream)
             (format stream "Failed to parse the line: ~a" (line c)))))

(defun normalize-expression (e)
  "Expressions come in in postfix notation and go out with each
operator having 2 arguments."
  (cond
    ((atom e) e)
    ((eq (first e) '\|)
     (list* (first e)
            (mapcar 'normalize-expression (cdr e))))
    (t
     (if (cdddr e)
         (normalize-expression (list* (first e)
                                      (list (first e)
                                            (second e)
                                            (third e))
                                      (cdddr e)))
         (list (first e)
               (normalize-expression (second e))
               (normalize-expression (third e)))))))

(defun equation-2-problem (e class initargs)
  (labels ((symbol (e)
             (and (stringp e)
                  (string/= e "?")))
           (unknown (e)
             (equal e "?"))
           (empty-or-number (bottom other unknowns)
             (let ((arg (convert bottom unknowns))
                   (tree (convert other unknowns)))
               (if (typep arg 'd:argument)
                   (progn
                     (setf (d:quantity tree) (d:quantity arg))
                     ;; a special case to allow empty single argument
                     ;; boxes in the middle of the tree.
                     (if (unknown bottom)
                         [a nil [m tree]]
                         tree))
                   tree)))
           (convert (e unknowns)
             (cond
               ((symbol e)
                (let ((sym (second (find e unknowns :key 'first :test 'string=))))
                  (if sym
                      [a nil sym]
                      (error "Cannot find symbol ~s in ~s" e unknowns))))
               ((unknown e)
                [a nil])
               ((or (numberp e)
                    (symbolp e))
                [a e])
               ((listp e)
                (cond
                  ((eq (first e) '=)
                    (cond
                      ((and (or (listp (second e)) (symbol (second e)))
                            (or (listp (third e)) (symbol (third e))))
                       (let ((left (convert (second e) unknowns))
                             (right (convert (third e) unknowns)))
                         [a nil (tree:child left) (tree:child right)]))
                      ((or (numberp (third e)) (unknown (third e)))
                       (empty-or-number (third e) (second e) unknowns))
                      ((or (numberp (second e)) (unknown (second e)))
                       (empty-or-number (second e) (third e) unknowns))
                      (t (error "gak"))))
                  ((eq (first e) '\|)
                   (make-instance 'd::invisible-box
                                  :children (mapcar (lambda (e) (change-class [a nil [m (convert e unknowns)]] 'd::invisible-argument)) (cdr e))))
                  (t
                    [a nil [m (convert (second e) unknowns) (convert (first e) unknowns) (convert (third e) unknowns)]])))
               (t (error "how do I convert: ~a" e))))
           (find-unknowns (e)
             (cond
               ((stringp e)
                (list e))
               ((listp e)
                (mapcan #'find-unknowns e))
               (t nil)))
           (init-unknowns (unknowns assigns)
             (let ((ret (loop for i in unknowns
                           for n = (third (find i assigns :key 'first :test 'string=))
                           if (or (numberp n) (null n))
                           collect (if (and (null n)
                                            ;; if the last letter in the symbol is an R,
                                            ;; then color the unknown red.
                                            (> (length (string i)) 1)
                                            (char-equal (char (string i) (1- (length (string i)))) #\r))
                                       `(,i ,[m [a nil :background (gwee:color 255 50 50)]])
                                       `(,i ,[m [a n]]))
                           ;; initialize a placeholder box that will be filled in in the next pass
                           else
                           collect `(,i ,[m] ,n))))
               (loop for i in ret
                  for n = (third i)
                  for box = (when n (tree:child (convert n ret)))
                  when box do
                    (setf (tree:children (second i)) (tree:children box)))
               ret)))
    (let* ((eqn (normalize-expression (first e)))
           (assigns (loop for i in (cdr e) collect (list (first i) (second i) (normalize-expression (third i)))))
           ;; symbols can have subtrees that themselves have unknowns
           ;; so initialize them too. And they must be initialized first.
           (assign-unknowns (mapcan #'find-unknowns (mapcar 'third assigns)))
           (unknowns (init-unknowns (union assign-unknowns (find-unknowns eqn) :test 'string=) assigns))
           ;; the parent slots get borked sometimes
           (diagram (tree:recreate-parent-slots (convert eqn unknowns))))
      (if (typep diagram 'd::invisible-box)
          `(,class :tree ,diagram ,@initargs)
          `(,class :tree ,[m diagram] ,@initargs)))))

(defun read-equation (string problem-class problem-initargs)
  (multiple-value-bind (ret rest) (handler-case
                                      (parse 'top string *rules2*)
                                    (rule-error () nil))
    (if (and ret (zerop (length rest)))
        (equation-2-problem ret problem-class problem-initargs)
        (progn
          (cerror "Skip this line." 'equation-read-error :line string)
          `(,problem-class :tree ,[m]
                           :instruction-title "This Problem Couldn't Be Parsed"
                           :instruction-body ,(format nil "The line was: ~s" string))))))

(defun equation-to-tree (string)
  (getf (cdr (read-equation string 'dummy nil)) :tree))

(defun read-section (stream problem-class problem-initargs problem-before problem-after between-problems)
  (when between-problems
    (error "between-problems is not implemented"))
  (loop for line = (read-line stream nil stream)
     until (or (eq line stream)
               (zerop (length (string-trim '(#\Space #\Tab) line))))
     append problem-before
     collect (read-equation line problem-class problem-initargs)
     append problem-after))

(defun read-session (file problem-class problem-initargs containers prologue epilogue intermission problem-before problem-after between-problems)
  (with-open-file (stream file)
    (let ((body `(,@prologue
                  ,@(loop for i = (read-section stream problem-class problem-initargs problem-before problem-after between-problems) while i
                       collect (list 'exp:subsequence :children i) into ret
                       append intermission into ret
                       finally (return (butlast ret)))
                  ,@epilogue)))
      (labels ((contain (list body)
                 (if list
                     `(,@(car list) :children
                         ,(if (cdr list)
                              (list (contain (cdr list) body))
                              (contain (cdr list) body)))
                     body)))
        (if containers
             `(,(pathname-name file) ,(contain containers body))
             `(,(pathname-name file) ,@body))))))

(defun read-all-sessions (problem-class &key
                          problem-initargs
                          containers
                          prologue
                          (epilogue `(exp:reward))
                          (intermission `(exp:message :text "Press Space To Continue"))
                          problem-before
                          problem-after
                          between-problems)
  (labels ((listify (list)
             (if (every 'listp list)
                 list
                 (list list))))
    (setf prologue (listify prologue)
          epilogue (listify epilogue)
          intermission (listify intermission)
          problem-before (listify problem-before)
          problem-after (listify problem-after)
          between-problems (listify between-problems))
    (let* ((dir (gwee:top-level-path (format nil "sessions/*.txt")))
           (sessions (mapcar (u:curry read-session (d) problem-class problem-initargs containers prologue epilogue intermission problem-before problem-after between-problems) (directory dir))))
      sessions)))

(defmacro with-display ((v) &body body)
  `(gwee:with-gui (1024 768 :font "sans.ttf" :background (gwee:gray 255) :foreground (gwee:gray 0))
     (let ((,v (make-instance 'tv:tree-view :width 1024 :height 764 :parent gwee:*top-view*
                              :event-callback (lambda (,v e)
                                                (when (typep e 'e:key-event)
                                                  (let ((ch (gwee:key-to-character (e:key e))))
                                                    (case ch
                                                      (#\u (decf (gwee:view-scroll-y ,v) 50)
                                                           (setf (gwee:view-needs-update-p ,v) t))
                                                      (#\d (incf (gwee:view-scroll-y ,v) 50)
                                                           (setf (gwee:view-needs-update-p ,v) t))
                                                      (#\Space (throw 'next nil)))))))))
       (gwee:sync-views)
       ,@body
       (throw 'gwee::quit nil))))

(defun display-trees (&rest trees)
  (with-display (v)
    (dolist (i trees)
      (setf (d:root v) i
            (gwee:view-scroll-y v) 0)
      (tv:refresh-tree v :center)
      (catch 'next
        (gwee:dispatch-events)))))

(defun display-solutions (n eqn)
  (with-display (v)
    (setf (d:root v) (getf (cdr (read-equation eqn nil nil)) :tree))
    (dotimes (d::*solution* n)
      (setf (gwee:view-scroll-y v) 0)
      (tv:refresh-tree v :center)
      (catch 'next (gwee:dispatch-events)))))

(defun display (&rest eqns)
  (apply 'display-trees
         (mapcar (lambda (e) (getf (cdr (read-equation e nil nil)) :tree)) eqns)))

(defun parse-keywords (keywords)
  (loop for rest = keywords then (cddr rest)
       while rest
       for key = (first rest)
       for value = (second rest)
       collect key
       collect (if (consp value)
                   (apply 'gwee:color value)
                   value)))

(defun make-node (cell)
  (let ((keywords (parse-keywords (member-if 'keywordp cell))))
    (apply 'make-instance
           (ecase (char (symbol-name (first cell)) 0)
             (#\B 'd:multi-argument-box)
             (#\T 'd:argument)
             (#\I 'd:number-input-argument))
           :id (first cell)
           keywords)))

(defun link-node (node cell others)
  (etypecase node
    (d:multi-argument-box
     (setf (tree:children node)
           (loop for a in (subseq cell 1 (position-if 'keywordp cell))
              for arg = (cond ((or (numberp a)
                                   (find a '(+ - / *)))
                               [a a])
                              (t (or (find a others :key 'd:id) [a])))
              collect arg)))
    ((or d:input-argument d:argument)
     (setf (d:quantity node) (second cell))
     (when (> (length cell) 2)
       (setf (tree:children node)
             (loop for b in (subseq cell 2 (position-if 'keywordp cell))
                for box = (find b others :key 'd:id)
                collect box))))))

(defun assemble-graph (list)
  (let ((nodes (mapcar (lambda (c) (make-node c)) list)))
    (loop for c in list
       for n in nodes
       do (link-node n c nodes))
    ;; invisible boxes should link parentless boxes if there are more
    ;; than one
    (let ((roots (u:collect-if (lambda (b)
                                 (and (typep b 'd:box)
                                      (null (tree:parents b))))
                               nodes)))
      (if (> (length roots) 1)
          (make-instance 'd:invisible-box
                         :children (mapcar (lambda (r)
                                             (make-instance 'd:invisible-argument
                                                            :children (list r)))
                                           roots))
          (first roots)))))

(defun parse-graph (string)
  (let ((graph (assemble-graph (loop

                                  with i = 0
                                  with value = nil
                                  do (multiple-value-setq (value i) (read-from-string string t nil :start i))
                                  collect value
                                  while (< i (length string))))))
    (cond
      ((null graph)
       (cerror "Skip this one" "There's no root node in graph: ~s" string)
       [m])
      ((tree:detect-loop graph)
       (cerror "Skip this one" "Infinite loop detected in graph: ~s" string)
       [m])
      (t
       graph))))
